{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.IntroInitDecls
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Introduce InitDecls to intermediate 
--
-- Precondition: all optimization should have been performed
-- prior to this.
--
--------------------------------------------------------------------------------

module OchreLang.IntroInitDecls
  ( 
    introInitDecls

  ) where

import OchreLang.CompilerMon
import qualified OchreLang.OrchSpec as OS
import OchreLang.Syntax
import OchreLang.SyntaxBase


import Control.Applicative
import Text.Printf


introInitDecls :: InstrumentSource -> Compiler InstrumentSource
introInitDecls src@(InstrumentSource { instr_src_inits  = decls
                                     , instr_src_instr  = instr }) = 
    (\ins1 -> src { instr_src_instr = ins1 }) <$> introDeclsInst decls instr

introDeclsInst :: [OS.InitDecl] -> Instrument -> Compiler Instrument
introDeclsInst decls inst@(Instrument { instr_main = main_expr}) =
    initDecls decls >>= \fn -> 
    return $ inst { instr_main = fn main_expr }


initDecls :: [OS.InitDecl] -> Compiler (Expr -> Expr)
initDecls []     = return id
initDecls (d:ds) = (.) <$> initDecl1 d <*> initDecls ds

initDecl1 :: OS.InitDecl -> Compiler (Expr -> Expr)
initDecl1 (OS.InitDecl vid e) = case makeFinal (getIdent vid) of
    Just fid -> LetValue fid <$> value e
    Nothing -> throwError "IntroInitDecls.initDecl1"
                          (printf "Unrecognized variable - %s" (getIdent vid))


value :: OS.Expr -> Compiler Value
value (OS.Lit v)            = return $ literal v

value (OS.Var vid)          =  case makeFinal (getIdent vid) of
    Just fid -> return $ Var fid
    Nothing -> throwError "IntroInitDecls.value" 
                          (printf "Unrecognized variable - %s" (getIdent vid))

value (OS.Pfield i )        = return $ Pfield i

value (OS.App pid args)     = FunCallV pid <$> mapM value args

value (OS.Cond ce e1 e2)    = 
    CondV <$> value ce <*> value e1 <*> value e2

value (OS.UnaryE op e)      = UnaryV op <$> value e
value (OS.BinE op e1 e2)    = BinV op <$> value e1 <*> value e2
value (OS.RelE op e1 e2)    = RelV op <$> value e1 <*> value e2


literal :: OS.Literal -> Value
literal (OS.Bool b)     = Bool b
literal (OS.Int i)      = Int i
literal (OS.Float d)    = Float d 
literal (OS.String s)   = String s


